

(in-package :oali.core)

;;;; type equivalence

(defun simplify (u)
  (let ((tu (type-of u)))
    (cond
      ;; signed T <=> T
      ((and (eq tu 'p-qualified-type) (eq 'signed (qualifier u)))
       (inferior-type u))

      ;; can't get simplified type
      (t u))))

(defun structural-eq (u v)
  "checks structural equivalence of types u and v"

  (setf u (simplify u))
  (setf v (simplify v))
  
  (let ((tu (type-of u)) (tv (type-of v)))
	;; same types
	(if (eq tu tv)
	    (cond
	      ;; builtins case
	      ((eq tu 'p-type-builtin) (eq (name u) (name v)))

	      ;; pointers case
	      ((eq tu 'p-type-pointer) (structural-eq (pointee-type u)
						      (pointee-type v)))

	      ;; unexpected types ???
	      (t (error "unexpected types are compared")))

	    ;; types are not identical
	    nil)))

(defun test-check-eq ()
  (let ((context (create-context)))
    (flet ((seq (u v) (let ((tu (gethash u (types context)))
			    (tv (gethash v (types context))))
			(if (and tu tv)
			    (structural-eq tu tv)
			    (error "no such type(s)")))))

      ;; TODO: string equivalence
      ;;(unless (string= "void *" ))

      (unless (and
	       (seq 'int 'int)
	       (not (seq 'int 'char))
	       (seq 'int 'sint))
	(error "structural equivalence test failed")))))


;;;; flow graph data structures

(defstruct expression)

;; represents certain simple value being used in function calls or set expressions
;; it might include symbol (e.g. variable reference), number or string
(defstruct (const-value (:include expression) (:conc-name expr-))
  (val nil :type (or symbol string number)))

;; represents lvalues, e.g. those things that potentially could be modified
(defstruct (lvalue (:include expression) (:conc-name expr-)))

(defstruct (var-expression (:include lvalue) (:conc-name expr-))
  (var nil :type symbol))

;; function call
(defstruct (function-call (:include lvalue) (:conc-name expr-))
  ;; origin could be:
  ;;    - a symbol, e.g. foo(1, 2)
  ;;    - other function call expression, e.g. (*pFoo)(1, 2)
  (origin nil :type (or symbol function-call))

  ;; arguments of the function being called
  ;;    - null indicates there is no such arguments
  ;;    - arguments array
  (args nil :type (or null (simple-array expression (*)))))



;; root for all the other nodes
(defstruct (node (:conc-name node-))
  ;; source form the node inferred from
  (source-form nil :type (or null cons))
  ;; next node or null
  (next nil :type (or null node)))

;; simple set expression, like `a=b', `foo=dc', etc.
(defstruct (simple-set (:include node) (:conc-name node-))
  (source nil :type lvalue)
  (dest nil :type expression))

(defstruct (enter-scope (:include node) (:conc-name node-))
  (scope-end nil :type (or null leave-scope)))

(defstruct (enter-var-scope (:include enter-scope) (:conc-name node-))
  (var nil :type var-expression))

(defstruct (enter-marker-scope (:include enter-scope) (:conc-name node-))
  (marker-id nil :type symbol))

(defstruct (leave-scope (:include node) (:conc-name node-))
  (scope-begin nil :type enter-scope))

;; represents if-condition, e.g. if (a == b) { do1(); }
;; `next' member points to then-sequence,
;; `else' member holds else-sequence
(defstruct (if-condition (:include node) (:conc-name node-))
  ;; condition that is tested
  (condition nil :type expression)
  ;; else block
  (else nil :type (or null node)))

;; simple eval statement that might be:
;;    - null (e.g. nothing, or `void' in terms of C), <=> no operation
;;    - var, implies symbolic var name
(defstruct (simple-eval (:include node) (:conc-name node-))
  (statement nil :type (or null expression)))


;; helper function that creates args
(defun make-args (&rest args)
  (make-array
   (length args)
   :element-type 'expression
   :initial-contents (loop for arg in args collect
			  (typecase arg
			    ((or string number) (make-const-value :val arg))
			    (expression arg)
			    (t (error (format nil
					      "unknown arg type: ~a"
					      (type-of arg))))))))

;;;; flow graph test function

;; simple flow representation:
;;  00:     t0 = read_num();
;;  01:     if (t0 % 2 == 0)
;;              { print("t0 is even") } // then-block
;;              { print("t0 is odd") } // else-block
;;  02:     return (void)
;;
;; TBD: equivalence scheme
(defun fg-get-flow-1 ()
  ;; flow steps
  (let* (
	 ;;             expressions
	 (t0-var (make-var-expression :var 't0))

	 ;;             flow steps
	 ;; in order to specify next steps they might be recorded in the
	 ;; other way around
	 
	 ;; entering lexical scope of the t0 variable
	 (s00 (make-enter-var-scope :var t0-var))
	 ;; t0 = read_num()
	 (s01 (make-simple-set
	       :source t0-var
	       :dest (make-function-call :origin 'read-num)))
	 ;; incompleted if block
	 (s02 (make-if-condition
	       :condition (make-function-call
			   :origin '=
			   :args (make-args
				  (make-function-call
				   :origin 'mode
				   :args (make-args t0-var 2))
				  0))))
	 ;; print ("t0 is even")
	 (s03 (make-simple-eval
	       :statement (make-function-call
			   :origin 'print
			   :args (make-args "t0 is even"))))

	 ;; print ("t0 is odd")
	 (s04 (make-simple-eval
	       :statement (make-function-call
			   :origin 'print
			   :args (make-args "t0 is odd"))))

	 ;; return (void)
	 (s05 (make-simple-eval)))

    ;; set flow markers
    (setf (node-next s00) s01)
    (setf (node-next s01) s02)

    (setf (node-next s02) s03)
    (setf (node-else s02) s04)

    (setf (node-next s03) s05)
    (setf (node-next s04) s05)

    ;; return entry value
    s00))

(defun fg-get-flow-2 ()
  (let* (
	 ;; expressions
	 (var-a (make-var-expression :var 'a))

	 ;; flow
	 (s0 (make-enter-var-scope	; introducing typeless a
	      :var var-a))
	 (s1 (make-leave-scope		; leave a visibility scope
	      :scope-begin s0))
	 (s2 (make-simple-eval))	; return
	 )

    ;; establish next steps
    (setf (node-next s0) s1)
    (setf (node-next s1) s2)

    ;; return flow entry
    s0))


(defun flow-graph-test ()
  (fg-get-flow-1))


;; flow graph c translator

(defstruct (c-tran-context (:conc-name ctc-))
  (ostream nil :type stream)
  ;; all the names in the scope shall be properly named
  (name-map (make-hash-table) :type hash-table))

;; printer
(defun prn (ctx val)
  (let ((os (ctc-ostream ctx)))
    (typecase val
      (string (write-string val os))
      (character (write-char val os))
      (symbol (write-string (princ-to-string val) os))
	      ;;(let ((name (gethash val (ctc-name-map ctx)))) (write-string (if name name (princ-to-string val)) os))
      (t (error (format nil "unknown value of type ~a" (type-of val)))))))

(defun prns (ctx &rest vals)
  (dolist (v vals)
    (prn ctx v)))

(defun c-print-expr (ctx expr)
  (check-type expr expression)
  (prn ctx expr))

(defun c-print-node (ctx node)
  (typecase node

    ;; enter var scope
    (enter-var-scope (let ((v (node-var node)))
		       (prns ctx "int" #\Space (expr-var v) #\;)))

    (leave-scope (let ((prev-enter-scope (node-scope-begin node)))
		   (prns ctx
			"// leaving "
			(type-of prev-enter-scope)
			" of " 
			(typecase prev-enter-scope
			  (enter-var-scope (expr-var (node-var prev-enter-scope)))
			  (t (error "unknown prev enter scope"))))))

    ;; simple evaluation
    (simple-eval (progn
		   ;; return?
		   (unless (node-next node) (prn ctx "return"))
		   (if (node-statement node)
		       (error "statement output is not implemented yet"))
		   (prn ctx #\;)))

    ;; unk type
    (t (error (format nil "unknown node ~a" node))))
  
  ;; go next line
  (prn ctx #\Newline))


(defun translate-to-c ()
  (let* ((ostream (make-string-output-stream))
	 (ctx (make-c-tran-context :ostream ostream)))
    ;;

    (do ((node (fg-get-flow-2)))
	((null node))
      ;; body
      (c-print-node ctx node)
            
      ;; go next
      (setf node (node-next node)))
    
    ;; return string
    (get-output-stream-string ostream)))


;;;; new features tester entry point

(defun new-features ()
  "tests for new features to be added"

  (test-check-eq)

  (flow-graph-test)

  (translate-to-c))

